perm filename LODLAP.VLI[VLI,LSP] blob
sn#382022 filedate 1978-09-08 generic text, type C, neo UTF8
COMMENT ā VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 L O D L A P . V L I
C00005 00003 3 LODMEM LODERR
C00009 00004 4 LODADR
C00011 00005 5 LODADR (suite)
C00012 00006 6 LOD : atomes COMMENT VALAP EVAL REGISTER
C00015 00007 7 LOD : (suite) END
C00018 00008 8 LOD : (suite) ENTRY OPCD QUOTE XWD EXP
C00021 00009 9 LAP LAPFILE LAPF
C00024 00010 10 MACLAP
C00026 00011 11 Macro LAP pour l'assembleur
C00029 00012 12 LAPSYMBOL LAPEND
C00032 ENDMK
Cā;
; L O D L A P . V L I ;
; Chargeur Assembleur VLISP 10 . 3 ;
;----------------------------------------------------------;
; Jerome CHAILLOUX ;
; ;
; Universite de Paris VIII - Vincennes ;
; Route de la Tourelle 75012 Paris ;
; Tel : 374 12 50 poste 299 ;
; ;
; I.R.C.A.M. ;
; 31 Rue St Merri 75004 Paris ;
; Tel : 277 12 33 poste 48-48 ;
;----------------------------------------------------------;
; ;
; regles de reconnaissance des identificateurs : ;
; ;
; 1er car. signification ;
; ;
; & fonctions d'echappements (ESCAPEs) ;
; * fonctions internes du lodlap ;
; - variables globales a tout le lodlap ;
; # variables libres pour certaines fonctions ;
; (mais liees par des fonctions du lodlap) ;
; ! indicateurs sur P-listes ;
; ? indicateurs du lodlap (e.g. T ou NIL) ;
; : symboles du LINK 10 connus du lodlap ;
; ;
;----------------------------------------------------------;
;;
; initialisations ;
;;
(STATUS 2 2)
;;
; pour eviter tout malentendu ... ;
(MAPC '(@ : + * % ! # $ & ?) (LAMBDA (X) (STATUS 19 X)))
;;
; INIT :MEM et :BCODEC ;
(SETQ :MEM (GETSYMBOL ':MEM))
(SETQ :BCODEE (STATUS 41 (GETSYMBOL ':BCODEE)))
; 3 LODMEM LODERR ;
(DE LODMEM (L)
; charge en memoire L ;
(SELECTQ (LENGTH L)
(0 ; nb ou EXP ; (IF ?sw1 (PRIN1 L)) (STATUS 41 #pc L))
(2 ; XWD ;
(IF ?sw1
(PROGN
(TTAB 11)
(PRIN1 (CAR L))
(TTAB 19)
(PRIN1 (CADR L))))
(STATUS 41
#pc
(LOGOR (LOGSHIFT (CAR L) 18)
(LOGAND 262143 (CADR L)))))
(5 ; instruction complete ;
(STATUS 41 #pc (STATUS 44 L))
(IF ?sw1
(PROGN
(PRIN1 (NEXTL L))
(TTAB 11)
(PRIN1 (NEXTL L))
(TTAB 14)
(PRIN1 (NEXTL L))
(TTAB 16)
(PRIN1 (CADR L))
(TTAB 19)
(PRIN1 (CAR L)))))
((STATUS 41 #pc (LODERR 'LODMEM L)) ; C'EST UNE ERREUR ;))
(IF (LT (INCR #pc) :BCODEE)
()
(INPUT)
(OUTPUT)
(PRINT "*** zone CODE pleine...")
(RESET)))))))
(DE LODERR (L X)
; erreur du LOD nom = valeur : ramene toujours 0 ;
(PRINT '** 'LAP '/e/r/r/o/r ': L '/i/n X)
0)
; 4 LODADR ;
(DE LODADR (adress half ;; X)
; calcule une adresse absolue ou relocatable ;
; half = T si c'est une partie gauche ;
(COND
((NULL adress) ; pas d'adresse ; 0)
((NUMBP adress) ; adresse absolue ; adress)
((ATOM adress)
; adresse symbolique ;
(IF (SETQ X (GET adress 'VALAP))
; ya deja une VALAP ;
X
; symbole inconnu ;
(COND
((MEMQ 'ENTRY (CDR adress))
; nom de fonction non encore apparue ;
(PUT adress (CONS #pc (GET adress '!uds)) '!uds)
0)
((MEMQ (TYPEFN adress) '(SUBR FSUBR VALAP))
; fonction standard ;
(SETQ
X
(LOGAND 262143
(STATUS 41 (PLUS :MEM 5 (LOC adress)))))
(PUT adress X 'VALAP)
X)
((SAMEPN adress ':)
; symbole du LINK ;
(SETQ X (OR (GETSYMBOL adress)
(LODERR 'GETSYMBOL adress)))
(PUT adress X 'VALAP)
X)
(T ; vrai symbole non encore defini ;
(PUT adress
(CONS (IF half (CONS #pc) #pc)
(GET adress '!uds))
'!uds)
(OR
(MEMQ adress #local)
(SETQ #Local (CONS adress #local)))
0))))
;;
; ATTENTION : la fonction LODADR continue ... ;
; 5 LODADR (suite) ;
;;
((NUMBP (CAR adress))
; adresse relocatable ;
(PLUS (CAR adress) #orig))
((SELECTQ (CAR adress)
(QUOTE
; objet LISP quelconque ;
(OR
(AND (LITATOM (CADR adress)) (MEMQ (CADR adress) SAV))
(NEWL SAV (CADR adress)))
(LOC (CADR adress)))
(:MEM ; adresse par rapport a MEM ;
(PLUS :MEM (LODADR (CADR adress))))
(+ ; calcul relocatable ou absolu ;
(APPLY 'PLUS (MAPCAR (CDR adress) 'LODADR)))
(* ; relatif au compteur d'assemblage ;
(PLUS #pc (LODADR (CADR adress))))
((LODERR 'adress adress))))))
; 6 LOD : atomes COMMENT VALAP EVAL REGISTER ;
(DE LOD (L ;; R)
; traite 1 instruction en langue chargeur ;
(IF ?sw1 (PROGN (PRIN1 #pc) (TTAB 7)))
(COND
((NULL L) ; on ingnore tous les NILs ;)
((NUMBP L) ; mot pret a etre charge ;
(LODMEM L))
((ATOM L)
; etiquette locale ;
(PUT L #pc 'VALAP)
(IF (SETQ X (GET L '!uds))
; resolution des references non-resolues ;
(PROGN
(MAPC X
(LAMBDA (X)
(IF (LISTP X)
; en partie gauche ;
(STATUS 43 (CAR X) #pc T)
; en partie droite ;
(STATUS 43 X #pc))))
(REMPROP L '!uds))))
((AND (LITATOM (CAR L)) (SETQ R (GET (CAR L) '!maclap)))
; appel de macro-lap ;
(LESCAPE (MAPC (APPLY R (CDR L)) 'LOD)))
((SELECTQ (CAR L)
((* COMMENT) ; commentaires ; NIL)
(VALAP
; definition de symboles (ABS & RELOC) ;
(IF (NOT (LITATOM (CADR L)))
(LODERR 'VALAP L)
(SETQ R (LODADR (CADDR L)))
(PUT (CADR L) R 'VALAP)
(AND ?sw1 (PRIN1 '= R))))
(MACLAP
; definition de macro-lap ;
(PUT (CADR L) (CONS LAMBDA (CDDR L)) '!maclap))
(EVAL
; demande d'appel a l'interprete ;
(SETQ R (EVAL (CADR L)))
(AND ?sw1 (PRIN1 '= R)))
(REGISTER
; definition de nouveaux registres ;
(IF
(OR
(NOT (LITATOM (CADR L)))
(NOT (NUMBP (CADDR L))))
(LODERR 'REGISTER L)
(PUT (CADR L) (CADDR L) 'REGISTER)
(AND ?sw1 (PRIN1 '= (CADDR L)))))
;;
; attention la fonction LOD continue ..... ;
; 7 LOD : (suite) END ;
;;
(END
; fin segment ;
(IF ?sw1 (TERPRI 2))
; controle des locales ;
(MAPC #local
(LAMBDA (#local)
(REMPROP #local 'VALAP)
(IF (SETQ R (GET #local '!uds))
(PRINT '!uds ': #local R))))
(SETQ #local)
(AND
(SETQ
SAV
(MAPCT SAV
(FUNCTION (LAMBDA (SAV)
(IF
(OR
(INUMBP SAV)
(AND
(LITATOM SAV)
(LE (LOC SAV) (LOC 'STOP))))
NIL
SAV)))))
(CDR ENTRY)
(PUT (CADR (CADR ENTRY)) SAV 'SAV))
(MAPC (CDR ENTRY)
(FUNCTION (LAMBDA (ENTRY)
(PRINT ENTRY)
(REMPROP (CADR ENTRY) EXPR)
(REMPROP (CADR ENTRY) FEXPR)
; mise du type et de l'@ speciale ;
(STATUS 41
(PLUS :MEM 5 (LOC (CADR ENTRY)))
(LOGOR (CAR ENTRY)
(LOGSHIFT (LOC (CADDR ENTRY)) 18)))
; mise de l'indicateur special des SUBRs ;
(IF (CAR (CDDDR ENTRY))
(STATUS 43
(PLUS :MEM 4 (LOC (CADR ENTRY)))
(ADD1 (CAR (CDDDR ENTRY)))
T)))))
(STATUS 41 (LODADR ':BCODEC) #pc)
(SETQ ENTRY (CONS) #orig #pc SAV NIL))
;;
; attention la fonction LOD continue ..... ;
; 8 LOD : (suite) ENTRY OPCD QUOTE XWD EXP ;
;;
(ENTRY
; point d'entree utilisateur ;
(PUT (CADR L) #pc 'VALAP)
(IF (SETQ X (GET (CADR L) '!uds))
(PROGN
(MAPC X (LAMBDA (X) (STATUS 43 X #pc)))
(REMPROP (CADR L) '!uds)))
(NCONC1 ENTRY (CONS #pc (CDR L))))
(OPCD
; definition de nouveaux opcodes ;
(IF
(OR
(NOT (LITATOM (CADR L)))
(NOT (NUMBP (CADDR L))))
(LODERR 'OPCD L)
(PUT (CADR L) (CADDR L) 'OPCD)
(AND ?sw1 (PRIN1 '= (CADDR L)))))
(QUOTE
; un objet lisp quelconque quote ;
(LODMEM [0 (LODADR L)]))
(EXP ; une expression ; (LODMEM (LODADR (CADR L))))
((XWD LIST)
; format 2 1/2 mots ;
(LODMEM [(LODADR (CADR L) T) (LODADR (CADDR L))]))
(T ; instruction normale ;
(COND
((SETQ
R
(COND
((NUMBP (CAR L)))
((OPCD (CAR L)))
((LODERR 'OPCD L))))
(SETQ X L)
(NEXTL L)
(LODMEM
[R
(IF (NULL (CAR L))
(PROGN (NEXTL L) 0)
(OR (REGISTER (NEXTL L)) (LODERR 'REG)))
(IF (NEQ (CAR L) '@) 0 (NEXTL L) 1)
(LODADR (NEXTL L))
(IF (NULL (CAR L))
(PROGN (NEXTL L) 0)
(OR (REGISTER (NEXTL L)) (LODERR 'REG)))])
(SETQ L X))
((LODMEM (LODERR 'LOD L))))))))
(IF ?sw1
(PROGN
(TTAB 28)
(STATUS 7 30)
(PRIN1 L)
(STATUS 7 0)
(TERPRI))))
; 9 LAP LAPFILE LAPF ;
(DE LAP (L ?sw1 ;; #pc #orig #local ENTRY SAV)
; ?sw1 = T si on veut le rsultat de l'assemblage ;
; #pc = compteur courant d'assemblage ;
; #orig = origine du debut de chargement ;
; #local = liste des etiquettes locales ;
; entry = liste des points d'entree ;
(SETQ
#pc (STATUS 41 (LODADR ':BCODEC))
#orig #pc
ENTRY (CONS)
SAV ())
(STATUS 6 8)
(IF ?sw1 (TERPRI))
(WHILE L (LOD (NEXTL L)))
(LOD '(END))
(STATUS 6 10)
'LAP)
(DE LAPFILE (filout filin ?sw1 ?filap ;; #pc #orig #local ENTRY SAV)
; ?filap = T si fichier LAP, = NIL si fichier VLA ;
(OUTPUT filout)
(STATUS 2 20)
(TERPRI 2)
(PRINC '* 10)
(PRIN1 'LAPFILE ': filout '= filin)
(PRINC '* 10)
(TERPRI 2)
(STATUS 6 8)
(DE EOF ()
(LOD '(END))
(STATUS 6 10)
(STATUS 1 20)
(REMPROP 'EOF EXPR)
(INPUT)
(OUTPUT)
(&pass1))
(INPUT (IF (LISTP filin) filin ['DSK (CONS filin 'LAP)]))
(SETQ
#pc (STATUS 41 (LODADR ':BCODEC))
#orig #pc
ENTRY (CONS)
SAV ())
(ESCAPE &pass1
(IF ?filap
(WHILE T (EVAL (READ)))
(WHILE T (LOD (READ)))))
filout)
(DF LAPF (F ;; X)
(SETQ X (OR
(IF (DIRECTORY () (CONS (CAR F) 'VLO)) 'VLO)
(IF (DIRECTORY () (CONS (CAR F) 'VLA)) 'VLA)
(IF (DIRECTORY () (CONS (CAR F) 'LAP)) 'LAP))
(OR X (LESCAPE "LAPF: Il n'y a pas de fichier correspondant."))
(LAPFILE ['DSK (CONS (CAR F) 'LOD) (GETPPN) \055]
['DSK (CONS (CAR F) X)]
(CADR F)
(EQ X 'LAP)))))))))
; 10 MACLAP ;
(DF MACLAP (L)
; definition d'une macro-LAP ;
(PUT (CAR L) (CONS LAMBDA (CDR L)) '!maclap))
(DF TMACLAP (L)
; test des macros du lod/lap ;
(APPLY (GET (CAR L) '!maclap) (CDR L))))
(DE ACCESS (REGD REGS)
; donne acces a regs (pour les mac-laps) ;
(CONS REGD
(IF (LISTP REGS)
(COND
((EQ (CAR REGS) QUOTE)
; constante VLISP ;
[[':MEM REGS]])
((EQ (CAR REGS) '%)
; objet en pile ;
['@ (CADR REGS) 'P])
([REGS]))
; acces normal ;
[':MEM REGS])))
; Macros Lap du compilateur ;
(MACLAP MACLAP (ATOM L X) (PUT ATOM [LAMBDA L X] '!maclap) NIL)
(MACLAP GETVAL (REGD ATOM) [['HLRZ REGD [':MEM [QUOTE ATOM]]]])
(MACLAP PUTVAL (REGS ATOM) [['HRLM REGS [':MEM [QUOTE ATOM]]]])
(MACLAP SETNIL (ATOM) [['HRRZS 0 [':MEM [QUOTE ATOM]]]])
(MACLAP CAR (REGD REGS) [(CONS 'HLRZ (ACCESS REGD REGS))])
(MACLAP CDR (REGD REGS) [(CONS 'HRRZ (ACCESS REGD REGS))])
(MACLAP RPLACA (REGS REGD) [(CONS 'HRLM (ACCESS REGD REGS))])
(MACLAP RPLACD (REGS REGD) [(CONS 'HRRM (ACCESS REGD REGS))])
(MACLAP ARRAY (REGD ATOM) [['HRRZ REGD ['+ ':MEM 5 [QUOTE ATOM]]]])
; 11 Macro LAP pour l'assembleur ;
(MACLAP CAAR (REGD REGS)
[['CAR REGD REGS] ['HLRZ REGD ':MEM REGD]])
(MACLAP CADR (REGD REGS)
[['CDR REGD REGS] ['HLRZ REGD ':MEM REGD]])
(MACLAP CDAR (REGD REGS)
[['CAR REGD REGS] ['HRRZ REGD ':MEM REGD]])
(MACLAP CDDR (REGD REGS)
[['CDR REGD REGS] ['HRRZ REGD ':MEM REGD]])
(MACLAP JPLIST (REG LAB)
[['CAML REG ':BLIST]
(IF (EQ LAB 'POPJ) '(POPJ P) ['JRST 0 LAB])])
(MACLAP JNLIST (REG LAB)
[['CAMGE REG ':BLIST]
(IF (EQ LAB 'POPJ) '(POPJ P) ['JRST 0 LAB])])
(MACLAP CONS (REG)
[['EXCH REG ':MEM 'FREE]
['EXCH 'FREE REG]])
(MACLAP CONSL (REG CAR CDR)
[(AND CDR (NEQ CDR REG) ['MOVEI REG 0 CDR])
(IF CDR
(IF CAR ['HRL REG CAR] ['HLLI REG 0])
(IF CAR ['HRLZ REG CAR] ['SETZ REG]))
'[CONS REG]])
(MACLAP CONSCAR (REG CAR CDR)
[(AND CDR (NEQ CDR REG) ['MOVEI REG 0 CDR])
(CONS (IF CDR 'HLL 'HLLZ) (ACCESS REG CAR))
['CONS REG]])
(MACLAP UNCONS (REG CAR CDR)
(IF (NEQ REG CDR)
[['HRRZ CDR ':MEM REG] ['HLRZ CAR ':MEM REG]]
[['HLRZ CAR ':MEM REG] ['HRRZ CDR ':MEM REG]]))
(MACLAP INCR (ATOM)
[['HLRZ 1 ['+ ':MEM [QUOTE ATOM]]]
'(PUSHJ P ADD1)
['HRLM 1 ['+ ':MEM [QUOTE ATOM]]]])
(MACLAP DECR (ATOM)
[['HLRZ 1 ['+ ':MEM [QUOTE ATOM]]]
'(PUSHJ P SUB1)
['HRLM 1 ['+ ':MEM [QUOTE ATOM]]]])
(MACLAP NEXTL (REG ATOM)
[['HLRZ REG ['+ ':MEM [QUOTE ATOM]]]
['HRRZ (ADD1 REG) ':MEM REG]
['HLRZ REG ':MEM REG]
['HRLM (ADD1 REG) ['+ ':MEM [QUOTE ATOM]]]])
; 12 LAPSYMBOL LAPEND ;
(DE LAPSYMBOL ()
; imprime tous les symboles utilises par le LAP ;
(TERPRI)
(TTAB 20)
(APPLY 'PRINT (EXPLODE 'SYMBOL))
(TERPRI 2)
(PUSH (STATUS 6))
(STATUS 6 8)
(MAPC (OBLIST)
(FUNCTION (LAMBDA (L X F)
(MAPC '(OPCD REGISTER VALAP !maclap SAV)
(FUNCTION (LAMBDA (I)
(AND (SETQ X (GET L I)) (SETQ F (CONS [I X] F))))))
(COND
(F (PRIN1 L)
(STATUS 7 15)
(WHILE F (TTAB 13) (PRINT (NEXTL F)))
(STATUS 7 0)
(TERPRI 0))))))
(STATUS 6 (POP))
(TERPRI))
(DE LAPEND (;; X)
; recupere la place du LOAD/LAP ;
(SETQ X (STATUS 21))
(MAPC (OBLIST)
(LAMBDA (X ;; Y)
(REMPROP X 'OPCD)
(REMPROP X 'REGISTER)
(REMPROP X 'ENTRY)
(REMPROP X 'VALAP)
(REMPROP X '!maclap)
(IF (SETQ Y (GET X '!uds)) (PRINT '!uds ': X Y))))
(MAPC
'(LODMEM LODADR LODERR LOD LAP LAPFILE ACCESS LAPSYMBOL
LAPEND) (LAMBDA (X) (REMPROP X EXPR)))
(MAPC '(LAPF MACLAP TMACLAP) (LAMBDA (X) (REMPROP X FEXPR)))
(AUTOLOAD LODLAP LAP LAPFILE LAPF)
(PRINT 'LAPEND '= (DIFFER (STATUS 21) X)))
(POUR EVAL (MAPC (MAPCAR (MAKLIST "SYS:LAP .VLI loaded.
") 'CASCII) 'TYO) (TERPRI))